home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / dialogs.tcl < prev    next >
Encoding:
Text File  |  2001-02-02  |  45.5 KB  |  1,507 lines
  1. ## -*-Tcl-*- (nowrap)
  2.  # ###################################################################
  3.  #  AlphaTcl - core Tcl engine
  4.  # 
  5.  #  FILE: "dialogs.tcl"
  6.  #                                    created: 12/1/96 {5:36:49 pm} 
  7.  #                                last update: 02/02/2001 {17:46:06 PM} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <vince@santafe.edu>
  10.  #    mail: 317 Paseo de Peralta, Santa Fe, NM 87501
  11.  #     www: <http://www.santafe.edu/~vince/>
  12.  #  
  13.  # Much copyright (c) 1997-2000  Vince Darley, all rights reserved, 
  14.  # rest Pete Keleher, Johan Linde.
  15.  # 
  16.  # Reorganisation carried out by Vince Darley with much help from Tom 
  17.  # Fetherston, Johan Linde and suggestions from the Alpha-D mailing list.  
  18.  # Alpha is shareware; please register with the author using the register 
  19.  # button in the about box.
  20.  #  
  21.  #  Description: 
  22.  # 
  23.  # Much more flexible dialogs for querying the user about flags and
  24.  # vars.  These may be global, mode-dependent, or package-dependent.
  25.  # 
  26.  # Things you may wish to do:
  27.  # 
  28.  #  dialog::pkg_options Pkg
  29.  #  
  30.  # creates a dialog for all array entries 'PkgmodeVars'.  These
  31.  # must have been previously declared using 'newPref'.  These
  32.  # variables are _not_ copied into the global scope; only
  33.  # existing as array entries.
  34.  # 
  35.  # Note that rather than setting up traces on variables, you are
  36.  # often better off using the optional proc argument to newPref;
  37.  # the name of a procedure to call if that element is changed by
  38.  # the user.
  39.  # 
  40.  # Use the procedure 'newPref' to declare preferences.  Why?  It has
  41.  # optional arguments which allow you to declare:
  42.  # 
  43.  #  lists
  44.  #  indexed lists
  45.  #  folders
  46.  #  files
  47.  #  bindings
  48.  #  menu-bindings
  49.  #  applications
  50.  #  variable-list elements
  51.  #  array elements
  52.  #  
  53.  # all of which can be set using the same central mode/global
  54.  # dialogs.
  55.  #  
  56.  # It also lets you add an optional procedure to call when an
  57.  # item changes...  Also if Alpha upgrades to Tcl 8 and namespaces, 
  58.  # it is easy to modify that central procedure to fit everything 
  59.  # with the new scheme.
  60.  # 
  61.  # Most modes will just want to declare their vars using newPref.  
  62.  # There is usually no need to do _anything_ else.
  63.  # 
  64.  # ---
  65.  # 
  66.  # The prefs dialog procs below were based upon Pete Keleher's 
  67.  # originals.
  68.  # ###################################################################
  69.  ##
  70.  
  71. namespace eval dialog {}
  72. namespace eval global {}
  73. namespace eval flag {}
  74.  
  75. # ◊◊◊◊ Toplevel dialog procedures ◊◊◊◊ #
  76.  
  77. ## 
  78.  # -------------------------------------------------------------------------
  79.  # 
  80.  # "dialog::pkg_options" --
  81.  # 
  82.  #  Make a dialog for the given package, with 'title' for the dialog box.
  83.  #  'not_global' indicates the variables are never copied into the global
  84.  #  scope, remaining in their array ${pkg}modeVars (or '$var' if it is given)
  85.  # 
  86.  #  There is now some support for '$var' not to represent an array, but
  87.  #  rather to be a namespace inside which the variables are placed. 
  88.  #  However this hasn't been tested much.
  89.  #  
  90.  # Results:
  91.  #  Nothing
  92.  # 
  93.  # Side effects:
  94.  #  May modify any of the given package's variables.
  95.  # 
  96.  # --Version--Author------------------Changes-------------------------------
  97.  #    1.0     <vince@santafe.edu> original
  98.  # -------------------------------------------------------------------------
  99.  ##
  100. proc dialog::pkg_options {pkg {title ""} {not_global 1} {var ""} {listOfVars ""}} {
  101.     if {!$not_global} {
  102.     # make sure the package variables are global
  103.     global ${pkg}modeVars
  104.     if {[info exists ${pkg}modeVars]} {
  105.         foreach v [array names ${pkg}modeVars] {
  106.         global $v
  107.         set $v [set ${pkg}modeVars($v)]
  108.         }
  109.     }
  110.     }
  111.     if {$title == ""} { 
  112.     set title "Preferences for the '[quote::Prettify $pkg]' package" 
  113.     }
  114.     if {$not_global} {
  115.     global dialog::_not_global_flag
  116.     if {$var == ""} {
  117.         set dialog::_not_global_flag ${pkg}modeVars
  118.     } else {
  119.         set dialog::_not_global_flag $var
  120.     }
  121.     }
  122.     if {[llength $listOfVars]} {
  123.     global dialog::_variablesForEditing
  124.     set dialog::_variablesForEditing $listOfVars
  125.     }
  126.     set err [catch {dialog::modifyModeFlags $title $not_global $pkg} result]
  127.     if {$not_global} {
  128.     global dialog::_not_global_flag
  129.     set dialog::_not_global_flag ""
  130.     }
  131.     if {[info exists dialog::_variablesForEditing]} {
  132.     unset dialog::_variablesForEditing
  133.     }
  134.     if {$err} {
  135.     error $result
  136.     }
  137. }
  138. proc dialog::edit_array {var {title ""}} {
  139.     if {$title == ""} {set title "Contents of '$var' array"}
  140.     dialog::pkg_options "" $title 1 $var
  141. }
  142. proc dialog::editOneOfMany {title var store tempStore {what ""}} {
  143.     global modifiedArrayElements modifiedVars $tempStore $store
  144.     if {[regexp {(.*)\(.*\)$} $var "" arr elt]} {
  145.     global $arr
  146.     } else {
  147.     global $var
  148.     }
  149.     set oldInfo [array get $tempStore]
  150.     if {[catch {dialog::pkg_options "" $title 1 $tempStore}] \
  151.       || ($oldInfo == [array get $tempStore])} {
  152.     return
  153.     }
  154.     set oldId [set $var]
  155.     if {![dialog::yesno -y "Update" -n "New $what" \
  156.       "Update [set $var] $what, or make a new one?"]} {
  157.     # Ask for new name
  158.     set name [eval prompt [list "Enter tag for new $what" \
  159.       "<Tag>" "Old ids:"] [array names $store]]
  160.     set ${store}($name) [array get $tempStore]
  161.     set $var $name
  162.     # Have to store Usual id too.
  163.     lappend modifiedArrayElements [list $name $store]
  164.     if {[regexp {(.*)\(.*\)$} $var "" arr elt]} {
  165.         lappend modifiedArrayElements [list $elt $arr]
  166.     } else {
  167.         lappend modifiedVars $var
  168.     }
  169.     } else {
  170.     set ${store}($oldId) [array get $tempStore]
  171.     }
  172.     lappend modifiedArrayElements [list $oldId $store]
  173. }
  174.  
  175. proc helperApps {} {
  176.     set sigs [info globals *Sig]
  177.     regsub -all {Sig} $sigs {} sigs
  178.     set sig [listpick -p "Change/inspect which helper?" [lsort -ignore $sigs]]
  179.     set sig ${sig}Sig
  180.     global $sig
  181.     if {![info exists $sig]} { set $sig "" }
  182.     set nsig [dialog::askFindApp $sig [set $sig]]
  183.     if {$nsig != "" && [set $sig] != $nsig} {
  184.     set $sig $nsig
  185.     prefs::modified $sig
  186.     }
  187. }
  188.  
  189. proc suffixMappings {} {
  190.     global filepats
  191.  
  192.     set dim [getMainDevice]
  193.     set screenwidth [expr {[lindex $dim 2] - [lindex $dim 0]}]
  194.     if {$screenwidth < 800} {
  195.     # Small screen
  196.     if {[catch {listpick -p "Select mode:" [lsort -ignore [array names filepats]]} mode] || $mode == ""} {return}
  197.     set newpats [prompt "Suffix mappings for $mode:" $filepats($mode)]
  198.     if {$newpats != $filepats($mode)} {
  199.         if {![is::List $newpats]} {
  200.         alertnote "'$newpats' is not a valid list of patterns.\
  201.           Please make sure \\\{,\\\} are properly\
  202.           quoted.  Your changes have been ignored."
  203.         } else {
  204.         prefs::addArrayElement filepats $mode $newpats
  205.         set filepats($mode) $newpats
  206.         }
  207.     }
  208.     } else {
  209.     set l1 5
  210.     set w1 38
  211.     set l2 [expr {$l1 + $w1 + 5}]
  212.     set w2 [expr {($screenwidth - 200)/2}]
  213.     if {$w2 > 400} { set w2 400 }
  214.     set h 18
  215.     set top 5
  216.     set mar 5
  217.     
  218.     set modes [lsort -ignore [array names filepats]]
  219.     set len [expr {[llength $modes] + 1}]
  220.     set modes1 [lrange $modes 0 [expr {$len/2 - 1}]]
  221.     set modes2 [lrange $modes [expr {$len/2}] end]
  222.     
  223.     foreach m $modes1 {
  224.         lappend items -t $m $l1 $top [expr {$l1 + $w1}] [expr {$top + $h}]
  225.         lappend items -e $filepats($m) $l2 $top [expr {$l2 + $w2}]
  226.         if {[string length $filepats($m)] > 60} {
  227.         lappend items [expr {$top + 2*$h - 2}]
  228.         incr top [expr {2*$h + $mar}]
  229.         } else {
  230.         lappend items [expr {$top + $h - 2}]
  231.         incr top [expr {$h + $mar}]
  232.         }
  233.     }
  234.     
  235.     set top2 5
  236.     set l1 [expr {$l2 + $w2 + 20}]
  237.     set l2 [expr {$l1 + $w1 + 5}]
  238.     foreach m $modes2 {
  239.         lappend items -t $m $l1 $top2 [expr {$l1 + $w1}] [expr {$top2 + $h}]
  240.         lappend items -e $filepats($m) $l2 $top2 [expr {$l2 + $w2}]
  241.         if {[string length $filepats($m)] > 60} {
  242.         lappend items [expr {$top2 + 2*$h - 2}]
  243.         incr top2 [expr {2*$h + $mar}]
  244.         } else {
  245.         lappend items [expr {$top2 + $h - 2}]
  246.         incr top2 [expr {$h + $mar}]
  247.         }
  248.     }
  249.     
  250.     if {$top2 > $top} {
  251.         set top $top2
  252.     }
  253.     incr top $mar
  254.     
  255.     set l1 5
  256.     lappend buts -b OK $l1 $top [expr {$l1 + 60}] [expr {$top + 20}]
  257.     lappend buts -b Cancel [expr {$l1 + 100}] $top [expr {$l1 + 160}] \
  258.       [expr {$top + 20}]
  259.     
  260.     if {[info tclversion] < 8.0} {
  261.         set res [eval [list dialog -w [expr {$l2 + $w2 + 10}] \
  262.           -h [expr {$top + 27}]] $buts $items]
  263.     } else {
  264.         set res [eval [list dialog -w [expr {$l2 + $w2 + 10}] \
  265.           -h [expr {$top + 27}] -T "Suffix mappings"] $buts $items]
  266.     }
  267.     
  268.     if {[lindex $res 0]} {
  269.         set res [lrange $res 2 end]
  270.         
  271.         set changed ""
  272.         foreach m [lsort -ignore [array names filepats]] {
  273.         if {$filepats($m) != [lindex $res 0]} {
  274.             if {[is::List [lindex $res 0]]} {
  275.             lappend changed [list $m [lindex $res 0]]
  276.             } else {
  277.             lappend errors $m
  278.             }
  279.         }
  280.         set res [lrange $res 1 end]
  281.         }
  282.         
  283.         foreach pair $changed {
  284.         eval prefs::addArrayElement filepats [lrange $pair 0 1]
  285.         set filepats([lindex $pair 0]) [lindex $pair 1]
  286.         }
  287.         if {[info exists errors]} {
  288.         alertnote "[join $errors ,]\
  289.           mode[expr {[llength $errors] > 1 ? {s} : {}}] had illegal\
  290.           lists of patterns. Please make sure \\\{,\\\} are properly\
  291.           quoted.  Changes to those modes have been ignored."
  292.         }
  293.     }
  294.     }
  295.     mode::updateSuffixes
  296. }
  297. ## 
  298.  # -------------------------------------------------------------------------
  299.  # 
  300.  # "dialog::flagsAndVars" --
  301.  # 
  302.  #  Takes a list of flags and variables (where the latter can in fact
  303.  #  contain sublists of stuff), and creates the dialog basing the
  304.  #  title for each item on its name, extracting help text as required,
  305.  #  and basing the type of each item on either its name or the type
  306.  #  which has been registered.
  307.  #  
  308.  #  The procedure used to be named 'dialog::mode', but has been 
  309.  #  renamed to reflect it's broader purpose.  It will return two lists,
  310.  #  the first of the values returned, the second of the variables which
  311.  #  should be set to those values.  The calling procedure should ensure
  312.  #  that the variables are actually set to these values!
  313.  #  
  314.  #  The current values for the flags/vars must be accessible, since
  315.  #  they will be required by the code this procedure calls.  By default
  316.  #  it is assumed each flag/var is a global variable, unless various
  317.  #  other information is declared in various globals.  The method
  318.  #  which is actually called to get the values is dialog::getFlag,
  319.  #  which usually calls dialog::getOldFlag.
  320.  #  
  321.  #  Please see those methods for details if you want to call this
  322.  #  procedure without using global variables.
  323.  # -------------------------------------------------------------------------
  324.  ##
  325. proc dialog::flagsAndVars {flags vars {title ""}} {
  326.     set lim [expr {10 - [llength $flags]/4}]
  327.     if {[llength $vars] > $lim } {
  328.     set args {}
  329.     set nvars [llength $vars]
  330.     set j 0
  331.     for {set i 0} {$i < $nvars} {incr i $lim ; set lim 10} {
  332.         lappend args [list "Page [incr j] of ${title}" $flags \
  333.           [lrange $vars $i [expr {$i+$lim -1}]]]
  334.         set flags ""
  335.     }
  336.     dialog::multipage $title $args
  337.     } else {
  338.     dialog::onepage $flags $vars $title
  339.     }
  340. }
  341. ## 
  342.  # -------------------------------------------------------------------------
  343.  # 
  344.  # "dialog::modifyModeFlags" --
  345.  # 
  346.  #  Currently 'not_global == 0' implies this is a mode, or at least that
  347.  #  the variables are stored in ${mm}modeVars(...)
  348.  #  
  349.  #  'not_global == 1' implies that the variables are stored in the
  350.  #  array/namespace given by the value of the variable
  351.  #  'dialog::_not_global_flag'
  352.  #  
  353.  # -------------------------------------------------------------------------
  354.  ##
  355. proc dialog::modifyModeFlags {{title ""} {not_global 0} {mm ""}} {
  356.     global mode invisibleModeVars \
  357.       dialog::_not_global_flag allFlags 
  358.     # Check whether this is a mode or package, and where variable values
  359.     # are stored, and whether that's at the global level as well as in
  360.     # an array...
  361.     if {$not_global} {
  362.     set storage ${dialog::_not_global_flag}
  363.     if {$title == ""} {
  364.         set title "Preferences for '${mm}' package"
  365.     }
  366.     } else {
  367.     if {$mm == ""} { 
  368.         set mm $mode 
  369.         if {$mm == ""} {
  370.         alertnote "No mode set!"
  371.         return
  372.         }
  373.     }
  374.     set storage ${mm}modeVars
  375.     if {$title == ""} {
  376.         set title "Preferences for '${mm}' mode"
  377.     }
  378.     }
  379.     # check for mode specific proc
  380.     if {[info commands ${mm}modifyFlags] != ""} {${mm}modifyFlags; return}
  381.     if {[info tclversion] >= 8.0} { set storage ::$storage }
  382.     set unsortedNames {}
  383.     global $storage ${storage}Invisible index::flags index::feature\
  384.       dialog::_variablesForEditing
  385.     if {[info exists dialog::_variablesForEditing]} {
  386.     set unsortedNames ${dialog::_variablesForEditing}
  387.     } elseif {[array exists $storage]} {
  388.     set unsortedNames [array names $storage]
  389.     } elseif {[namespace_exists $storage]} {
  390.     foreach var [info vars ${storage}::*] {
  391.         # Caution: Tcl 8 or newer only.
  392.         lappend unsortedNames [namespace tail $var]
  393.     }
  394.     }
  395.     if {[llength $unsortedNames]} {
  396.     set mflags {}
  397.     set mvars {}
  398.     set colors {}
  399.     set rest {}
  400.     foreach i $unsortedNames {
  401.         if {[regexp {Colou?r$} $i]} {
  402.         lappend colors $i
  403.         } else {
  404.         lappend rest $i
  405.         }
  406.     }
  407.     
  408.     foreach v [concat [lsort $rest] [lsort $colors]] {
  409.         if {[info exists invisibleModeVars($v)] \
  410.           || [info exists ${storage}Invisible($v)]} continue
  411.         
  412.         if {[lsearch -exact $allFlags $v] >= 0} {
  413.         lappend mflags $v
  414.         } else {
  415.         lappend mvars $v
  416.         }
  417.     }
  418.     foreach pkg [set index::flags] {
  419.         if {[lsearch -exact [lindex [set index::feature($pkg)] 1] $mm] != -1} {
  420.         lappend mflags $pkg
  421.         }
  422.     }
  423.     if {![llength $mflags] && ![llength $mvars]} {
  424.         alertnote "There are no preferences!"
  425.         return
  426.     }
  427.     if {[catch {dialog::flagsAndVars $mflags $mvars $title} values_items]} {
  428.         return
  429.     }
  430.     dialog::adjust_flags \
  431.       [expr {$not_global ? "arraynamespace" : "arrayglobal"}] \
  432.       $values_items $storage
  433.     } else {
  434.     alertnote "The '$mm' mode/package has no preference settings."
  435.     }
  436.     
  437.     hook::callAll dialog::modifyModeFlags $mm $title
  438.     
  439. }
  440.  
  441. proc global::allPrefs {{which "AllPreferences"}} {
  442.     dialog::resetModified
  443.     global flagPrefs varPrefs
  444.     global::updateHelperFlags
  445.     global::updatePackageFlags
  446.     set AllPreferences [array names flagPrefs]
  447.     set InterfacePreferences {Appearance Completions Electrics Text Tiling Window}
  448.     set Input-OutputPreferences {Backups Files Printer Tags WWW}
  449.     set SystemPreferences [lremove -l $AllPreferences \
  450.       $InterfacePreferences ${Input-OutputPreferences} Packages]
  451.     foreach nm [set [join ${which} ""]] {
  452.     lappend args [list $nm $flagPrefs($nm) $varPrefs($nm)]
  453.     }
  454.     dialog::is_global {
  455.     dialog::adjust_flags global [dialog::multipage $which $args]
  456.     }
  457. }
  458.  
  459. proc dialog::preferences {menu nm} {
  460.     global flagPrefs varPrefs
  461.     if {[string match "Suffix Mappings" $nm]} {
  462.     return [suffixMappings]
  463.     } elseif {[string match "Menus And Features" $nm]} {
  464.     return [global::menusAndFeatures]
  465.     } elseif {[string match "Menus" $nm]} {
  466.     return [global::menus]
  467.     } elseif {[string match "Features" $nm]} {
  468.     return [global::features]
  469.     } elseif {[string match "Save Preferences Now" $nm]} {
  470.     return [prefs::saveNow]
  471.     } elseif {[string match "Edit Prefs File" $nm]} {
  472.     return [prefs::tclEdit]
  473.     }
  474.     if {![info exists flagPrefs($nm)]} { 
  475.     set nm "[string toupper [string index $nm 0]][string range $nm 1 end]" 
  476.     }
  477.     if {[string match "*Preferences" $nm]} { return [global::allPrefs $nm] }
  478.     if {$nm == "Packages"} { global::updatePackageFlags }
  479.     if {$nm == "Helper Applications"} { global::updateHelperFlags }
  480.     dialog::is_global {
  481.     dialog::adjust_flags global [dialog::onepage $flagPrefs($nm) $varPrefs($nm) "$nm preferences…"]
  482.     }
  483. }
  484.  
  485. # Dominique's nice proc to handle all packages at once.
  486. proc global::allPackages {} {
  487.     global package::prefs allFlags dialog::_not_global_pkg dialog::_not_global_flag
  488.     global flagPrefs varPrefs alpha::prefs
  489.     global::updatePackageFlags
  490.     set args {}
  491.     set dialog::_not_global_pkg {}
  492.     if {[info exists package::prefs]} {
  493.     set pkglist [concat ${package::prefs} [list miscellaneousPackages]]
  494.     } else {
  495.     set pkglist [list miscellaneousPackages]
  496.     }
  497.     foreach pkg [lsort -ignore $pkglist] {
  498.     if {$pkg == "miscellaneousPackages"} {
  499.         lappend args [list miscellaneousPackages $flagPrefs(Packages) $varPrefs(Packages)]
  500.         continue
  501.     }
  502.     if {[info exists alpha::prefs($pkg)]} {
  503.         set pkg [set alpha::prefs($pkg)]
  504.     }
  505.     global ${pkg}modeVars
  506.     set mflags {}
  507.     set mvars {}
  508.     if {[array exists ${pkg}modeVars]} {
  509.         lappend dialog::_not_global_pkg ${pkg}modeVars
  510.         foreach v [lsort [array names ${pkg}modeVars]] {
  511.         if {[lsearch -exact $allFlags $v] >= 0} {
  512.             lappend mflags $v
  513.         } else {
  514.             lappend mvars $v
  515.         }
  516.         }
  517.     }
  518.     lappend args [list $pkg $mflags $mvars]
  519.     }
  520.  
  521.     set values_items [dialog::multipage "Packages preferences" $args]
  522.     #set values_items [dialog::multipage [concat "package" ${package::prefs}] $args]
  523.     set dialog::_not_global_flag {}
  524.     set res [lindex $values_items 0]
  525.     set editItems [lindex $values_items 1]
  526.     set i 0
  527.     set values {}
  528.     set items {}
  529.     foreach item $editItems {
  530.     global $item
  531.     if {[info exists $item]} {
  532.         lappend values [lindex $res $i]
  533.         lappend items $item
  534.     } 
  535.     incr i
  536.     }
  537.     dialog::adjust_flags global [list $values $items]
  538.     foreach pkg ${dialog::_not_global_pkg} {
  539.     set i 0
  540.     set values {}
  541.     set items {}
  542.     foreach item $editItems {
  543.         if {[info exists ${pkg}($item)]} {
  544.         lappend values [lindex $res $i]
  545.         lappend items $item
  546.         } 
  547.         incr i
  548.     }
  549.     set dialog::_not_global_flag $pkg
  550.     dialog::adjust_flags arraynamespace [list $values $items] $pkg
  551.     }
  552.     unset dialog::_not_global_pkg
  553.     set dialog::_not_global_flag {}
  554. }
  555.  
  556. # ◊◊◊◊ Simple queries and alerts ◊◊◊◊ #
  557.  
  558. ## 
  559.  # -------------------------------------------------------------------------
  560.  # 
  561.  # "dialog::value_for_variable" --
  562.  # 
  563.  #  Ask for a value, with default given by the given variable, and using
  564.  #  that variable's type (list, file, ...) as a constraint.
  565.  #  
  566.  #  Currently assumes the variable is a list var, but this will change.
  567.  # -------------------------------------------------------------------------
  568.  ##
  569. proc dialog::value_for_variable {var {title ""}} {
  570.     if {$title == ""} { set title [quote::Prettify $var] }
  571.     return [dialog::optionMenu $title [flag::options $var] \
  572.       [uplevel [list set $var]]]
  573. }
  574.  
  575. ## 
  576.  # -------------------------------------------------------------------------
  577.  # 
  578.  # "dialog::getAKey" --
  579.  # 
  580.  #  Returns a keystring to be used for binding a key in a menu, 
  581.  #  using a nice dialog box to ask the user.
  582.  # 
  583.  #  Possible improvements: we could replace the dialog
  584.  #  box with a status-line prompt (which would allow the use of
  585.  #  getModifiers to check what keys the user pressed).
  586.  #  
  587.  #  Now handles 'prefixChar' bindings for non-menu items.
  588.  #  i.e. you can use this dialog to bind something to 'ctrl-x ctrl-s',
  589.  #  for instance.
  590.  # 
  591.  #  If the name contains '/' it is considered to be two items,
  592.  #  separated by that '/', which are to take the same binding,
  593.  #  except that one of them will use the option key.
  594.  #  
  595.  #  Similarly '//' means use shift, '///' means shift-option,
  596.  #  For instance 'dialog::getAKey close/closeAll//closeFloat /W<O'
  597.  #  would give you the menu-item for 'close' in the file menu. 
  598.  #  except these last two aren't implemented yet ;-)
  599.  # --Version--Author------------------Changes-------------------------------
  600.  #    1.0     Johan Linde         original
  601.  #    1.1     <vince@santafe.edu> can do non-menu bindings too
  602.  #    1.2     <vince@santafe.edu> handles arrow keys
  603.  #    1.2.1   Johan Linde        handles key pad keys
  604.  # -------------------------------------------------------------------------
  605.  ##
  606. proc dialog::getAKey {{name {}} {keystr {}} {for_menu 1}} {
  607.     global keys::func
  608.     # two lists for any other keys which look better with a text description
  609.     set otherKeys {"<No binding>" "-" Space}
  610.     set otherKeyChars [list "" "" " "]
  611.     if {!$for_menu} {
  612.     lappend otherKeys Left Right Up Down "Key pad =" \
  613.       "Key pad /" "Key pad *" "Key pad -" "Key pad +" "Key pad ."
  614.     lappend otherKeyChars "" "" "\x10" "" Kpad= \
  615.       Kpad/ Kpad* Kpad- Kpad+ Kpad.
  616.     for {set i 0} {$i < 10} {incr i} {
  617.         lappend otherKeys "Key pad $i"
  618.         lappend otherKeyChars Kpad$i
  619.     }
  620.     }
  621.     set nname $name
  622.     set shift-opt [expr {![regsub {///} $nname { so-} $nname]}]
  623.     set shift  [expr {![regsub {//} $nname { s-} $nname]}]
  624.     set option [expr {![regsub {/} $nname { o-} $nname]}]
  625.     if {[string length $keystr]} {
  626.     set values "0 0"
  627.     set mkey [keys::verboseKey $keystr normal]
  628.     if {$normal} {
  629.         lappend values "Normal Key"
  630.     } else {
  631.         lappend values $mkey
  632.         set mkey {}
  633.     }
  634.     lappend values [regexp {<U} $keystr]
  635.     lappend values [regexp {<B} $keystr]
  636.     if {!$for_menu} {
  637.         if {[regexp "«(.*)»" $keystr "" i]} {
  638.         if {$i == "e"} {
  639.             lappend values "escape"
  640.         } else {
  641.             lappend values "ctrl-$i"
  642.         }
  643.         } else {
  644.         lappend values "<none>"
  645.         }
  646.     }
  647.     if {$option} {lappend values [regexp {<I} $keystr]}
  648.     lappend values [regexp {<O} $keystr]
  649.     lappend values $mkey
  650.     } else {
  651.     set values {0 0 "" 0 0}
  652.     if {!$for_menu} { lappend values <none> }
  653.     if {$option} {lappend values 0}
  654.     lappend values 0 ""
  655.     }
  656.     if {$for_menu} {
  657.     set title "Menu key binding"
  658.     } else {
  659.     set title "Key binding"
  660.     set prefixes [keys::findPrefixChars]
  661.     foreach i $prefixes {
  662.         lappend prefix "ctrl-$i"
  663.     }
  664.     lappend prefixes e
  665.     lappend prefix "escape"
  666.     }
  667.     if {$name != ""} { append title " for '$name'" }
  668.     set usep [info exists prefix]
  669.     global alpha::modifier_keys
  670.     while {1} {
  671.     set box ""
  672.     # Build box
  673.     if {[info tclversion] < 8.0} {
  674.         lappend box -t $title 10 10 315 25
  675.     } else {
  676.         lappend box -T $title
  677.     }
  678.     lappend box -t Key 10 40 40 55 \
  679.       -m [concat [list [lindex $values 2]] \
  680.       [list "Normal key"] $otherKeys ${keys::func}] 80 40 180 57 \
  681.       -c Shift [lindex $values 3] 10 70 60 85 \
  682.       -c Control [lindex $values 4] 80 70 150 85
  683.     if {$usep} {
  684.         lappend box -t Prefix 190 40 230 55  \
  685.           -m [concat [list [lindex $values 5]]  "<none>" "-" $prefix] \
  686.           235 40 315 57
  687.     }
  688.     if {$option} {
  689.         lappend box -c [lindex ${alpha::modifier_keys} 2] \
  690.           [lindex $values [expr {5 + $usep}]] 160 70 220 85
  691.     }
  692.     lappend box -c [lindex ${alpha::modifier_keys} 0] \
  693.       [lindex $values [expr {5 + $option +$usep}]] 230 70 315 85
  694.     lappend box -n "Normal key" -e [lindex $values [expr {6 + $option +$usep}]] 50 40 70 55
  695.     set values [eval [concat dialog -w 330 -h 130 -b OK 20 100 85 120 -b Cancel 105 100 170 120 $box]]
  696.     # Interpret result
  697.     if {[lindex $values 1]} {error "Cancel"}
  698.     # work around a little Tcl problem
  699.     regsub "\{\{\}" $values "\\\{" values
  700.     set elemKey [string toupper [string trim [lindex $values [expr {6 + $option +$usep}]]]]
  701.     set special [lindex $values 2]
  702.     set keyStr ""
  703.     if {[lindex $values 3]} {append keyStr "<U"}
  704.     if {[lindex $values 4]} {append keyStr "<B"}
  705.     if {$option && [lindex $values [expr {5 + $usep}]]} {append keyStr "<I"}
  706.     if {[lindex $values [expr {5 + $option +$usep}]]} {append keyStr "<O"}
  707.     if {$usep} {
  708.         set pref [lindex $values 5]
  709.         if {$pref != "<none>"} {
  710.         set i [lsearch -exact $prefix $pref]
  711.         append keyStr "«[lindex $prefixes $i]»"
  712.         }
  713.     }
  714.     if {[string length $elemKey] > 1 && $special == "Normal key"} {
  715.         alertnote "You should only give one character for key binding."
  716.     } else {
  717.         if {$for_menu} {
  718.         if {$special == "Normal key" && [text::Ascii $elemKey] > 126} {
  719.             alertnote "Sorry, can't define a key binding with $elemKey."
  720.         } elseif {$elemKey != "" && $special == "Normal key" && ($keyStr == "" || $keyStr == "<U")} {
  721.             alertnote "You must choose at least one of the modifiers control, option and command."
  722.         } elseif {![regexp {F[0-9]} $special] && $special != "Tab" && $special != "Normal key" && $special != "<No binding>" && $keyStr == ""} {
  723.             alertnote "You must choose at least one modifier."
  724.         } else {
  725.             break
  726.         }
  727.         } else {
  728.         break
  729.         }
  730.     }
  731.     }
  732.     if {$special == "<No binding>"} {set elemKey ""}
  733.     if {$special != "Normal key" && $special != "<No binding>"} {
  734.     if {[set i [lsearch -exact $otherKeys $special]] != -1} {
  735.         set elemKey [lindex $otherKeyChars $i]
  736.     } else {
  737.         set elemKey [text::Ascii [expr {[lsearch -exact ${keys::func} $special] + 97}] 1]
  738.     }
  739.     }
  740.     if {![string length $elemKey]} {
  741.     set keyStr ""
  742.     } else {
  743.     append keyStr "/$elemKey"
  744.     }    
  745.     return $keyStr
  746. }
  747.  
  748. ## 
  749.  # -------------------------------------------------------------------------
  750.  # 
  751.  # "dialog::optionMenu" --
  752.  # 
  753.  #  names is the list of items.  An item '-' is a divider, and empty items
  754.  #  are not allowed.
  755.  # -------------------------------------------------------------------------
  756.  ##
  757. proc dialog::optionMenu {prompt names {default ""} {index 0}} {
  758.     if {$default == ""} {set default [lindex $names 0]}
  759.     
  760.     set y 5
  761.     set w [expr {[string length $prompt] > 20 ? 350 : 200}]
  762.     if {[string length $prompt] > 60} { set w 500 }
  763.     
  764.     # in case we need a wide pop-up area that needs more room
  765.     set popUpWidth [eval dialog::_reqWidth $names]
  766.     set altWidth [expr {$popUpWidth + 60}]
  767.     set w [expr {$altWidth > $w ? $altWidth : $w}]
  768.     
  769.     set dialog [dialog::text $prompt 5 y [expr {int($w/6.7)}]]
  770.     incr y 10
  771.     eval lappend dialog [dialog::menu 30 y $names $default $popUpWidth]
  772.     incr y 20
  773.     eval lappend dialog [dialog::okcancel [expr {$w - 160}] y 0]
  774.     set res [eval dialog -w $w -h $y $dialog]
  775.     
  776.     if {[lindex $res 2]} { error "Cancel" } 
  777.     # cancel was pressed
  778.     if {$index} {
  779.     # we have to take out the entries correponding to pop-up 
  780.     # menu separator lines -trf
  781.     set possibilities [lremove -all $names "-"]
  782.     return [lsearch -exact $possibilities [lindex $res 0]]
  783.     } else {
  784.     return [lindex $res 0]
  785.     }
  786. }
  787.  
  788. proc dialog::getUrl {{prompt "Please type your url, or use one of the buttons below"} {url ""}} {
  789.     while {1} {
  790.     set y 5
  791.     set w 380
  792.     if {[info tclversion] >= 8.0} {
  793.         set dialog [list -T "Select URL"]
  794.     } else {
  795.         set dialog [list]
  796.     }
  797.     
  798.     eval lappend dialog [dialog::text $prompt 5 y [expr {int($w/6.7)}]]
  799.     incr y 10
  800.     eval lappend dialog [dialog::edit $url 10 y 35]
  801.     incr y 5
  802.     eval lappend dialog [dialog::button "Pick local file…" 10 y \
  803.       "Use foremost browser page" 150 y]
  804.     eval lappend dialog [dialog::okcancel [expr {$w - 160}] y 0]
  805.     set res [eval dialog -w $w -h $y $dialog]
  806.     
  807.     if {[lindex $res 1]} {
  808.         # pick local file
  809.         if {[string range $url 0 6] == "file://"} {
  810.         set default [string range $url 7 end]
  811.         } else {
  812.         set default ""
  813.         }
  814.         if {![catch {getfile "Pick local file to use as url" $default} file]} {
  815.         regsub -all { } $file {%20} file
  816.         set url "file:///$file"
  817.         }
  818.     } elseif {[lindex $res 2]} {
  819.         # use browser page
  820.         if {[catch {url::browserWindow} res]} {
  821.         alertnote "Can't get that information: $res"
  822.         } else {
  823.         set url $res
  824.         }
  825.     } elseif {[lindex $res 3]} { 
  826.         # ok
  827.         return [lindex $res 0] 
  828.     } elseif {[lindex $res 4]} { 
  829.         # cancel
  830.         error "Cancel" 
  831.     }
  832.     }
  833. }
  834.  
  835. ## 
  836.  # -------------------------------------------------------------------------
  837.  # 
  838.  # "dialog::alert" --
  839.  # 
  840.  #  Identical to 'alertnote' but copes with larger blocks of text, and
  841.  #  resizes to that text as appropriate.
  842.  # -------------------------------------------------------------------------
  843.  ##
  844. proc dialog::alert {args} {
  845.     eval [list dialog::yesno -y "Ok" -n ""] $args
  846. }
  847.  
  848. proc dialog::errorAlert {args} {
  849.     eval dialog::alert $args
  850.     error [lindex $args 0]
  851. }
  852.  
  853. ## 
  854.  # -------------------------------------------------------------------------
  855.  # 
  856.  # "dialog::yesno" --
  857.  # 
  858.  #  Make a dialog with between 1 and 3 buttons, representing '1', '0' and
  859.  #  error "Cancel" respectively.  The names of the first two can be given
  860.  #  with '-y name' and '-n name' respectively.  The cancel button is
  861.  #  only used if a '-c' flag is given (and its name is fixed).
  862.  #  
  863.  #  The procedure automatically sizes the dialog and buttons to fit the
  864.  #  enclosed text.
  865.  # -------------------------------------------------------------------------
  866.  ##
  867. proc dialog::yesno {args} {
  868.     # too long for Alpha's standard dialog
  869.     getOpts {-y -n}
  870.     set prompt [lindex $args 0]
  871.     set y 5
  872.     set w [expr {[string length $prompt] > 20 ? 350 : 200}]
  873.     if {[string length $prompt] > 60} { set w 500 }
  874.     
  875.     set dialog [dialog::text $prompt 5 y [expr {int($w/6.7)}]]
  876.     incr y 10
  877.     set x 10
  878.     if {[info exists opts(-y)] && $opts(-y) != ""} {
  879.     lappend buttons $opts(-y) "" y
  880.     } else {
  881.     lappend buttons "Yes" "" y
  882.     }
  883.     if {[info exists opts(-n)]} {
  884.     if {$opts(-n) != ""} {
  885.         lappend buttons $opts(-n) "" y
  886.     }
  887.     } else {
  888.     lappend buttons "No" "" y
  889.     }
  890.     if {[info exists opts(-c)]} {
  891.     lappend buttons "Cancel" "" y
  892.     }
  893.     eval lappend dialog [eval dialog::button $buttons]
  894.     if {$x > $w} { set w [expr {$x + 15}] }
  895.     set res [eval dialog -w $w -h $y $dialog]
  896.     if {[lindex $res 0]} {
  897.     return 1
  898.     } elseif {[lindex $res 1]} {
  899.     return 0
  900.     } else {
  901.     error "cancelled"
  902.     }
  903. }
  904.  
  905. proc dialog::password {{msg "Please enter password:"}} {
  906.     set values [dialog -w 300 -h 90 -t $msg 10 20 290 35 \
  907.       -e "" 10 40 290 42 -b OK 20 60 85 80 -b Cancel 105 60 170 80]
  908.     if {[lindex $values 2]} {error "Cancel"}
  909.     return [lindex $values 0]
  910. }
  911.  
  912. proc dialog::logon {pkg {msg "Log on as…"} {connect "Connect"} {cancel "Cancel"} {var ""}} {
  913.     set y 20
  914.  
  915.     global dialog::_not_global_flag
  916.     if {$var == ""} {
  917.     set dialog::_not_global_flag ${pkg}modeVars
  918.     } else {
  919.     set dialog::_not_global_flag $var
  920.     }
  921.     
  922.     if {$msg != ""} {
  923.     set dialog [dialog::title $msg 480]
  924.     incr y 25
  925.     }
  926.     
  927.     eval lappend dialog [dialog::buildSection {userName userPassword} y]
  928.     incr y 10
  929.     set x 300
  930.     eval lappend dialog [dialog::button $connect "" y $cancel "" y ]
  931.     set res [eval dialog -w 480 -h $y $dialog]
  932.     
  933.     dialog::modified userName [lindex $res 0]
  934.     dialog::modified userPassword [lindex $res 1]        
  935.     
  936.     # 1 if "connect", 0 if "cancel"
  937.     return [lindex $res 2]
  938. }
  939.  
  940. # ◊◊◊◊ Finding applications ◊◊◊◊ #
  941.  
  942.  
  943. proc dialog::askFindApp {var sig} {
  944.     if {$sig == ""} {
  945.     set text "Currently unassigned.   Set?"
  946.     } elseif {[catch {nameFromAppl '$sig'} name]} {
  947.     set text "App w/ sig '$sig' doesn't seem to exist.   Change?"
  948.     } else {
  949.     set text "Current value is '$name'.   Change?"
  950.     }
  951.     if {[dialog::yesno $text]} {
  952.     set nsig [dialog::findApp $var $sig]
  953.     set app [nameFromAppl $nsig]
  954.     if {[dialog::yesno "Are you sure you want to set $var to '$nsig'\
  955.       (mapped to '$app')?"]} {
  956.         return $nsig
  957.     }
  958.     }
  959.     return ""
  960. }
  961.  
  962. # The optional second argument can be used to prompt the user
  963. # with the 'old' value 
  964. proc dialog::findApp {var {sig ""}} {
  965.     global ${var}s modifiedVars
  966.     if {[info exists ${var}s]} {
  967.     # have a list of items
  968.     set sigs [set ${var}s]
  969.     
  970.     set s 0
  971.     foreach f $sigs {
  972.         if {![catch {nameFromAppl $f} path]} {
  973.         lappend items [file tail $path]
  974.         lappend itemsigs $f
  975.         incr s
  976.         }
  977.     }
  978.     if {$s} {
  979.         lappend items "-" "Locate manually…"
  980.         if {[catch {dialog::optionMenu "Select a new helper for '$var':" \
  981.           $items "" 1} p]} {
  982.         return ""
  983.         }
  984.         # we removed a bunch of items above, so have to look here
  985.         if {$p < $s} {
  986.         return [lindex $itemsigs $p]
  987.         }
  988.     }
  989.     if {!$s || $p >= $s} {
  990.         set nsig [dialog::_findApp $var $sig]
  991.         if {$nsig != ""} {
  992.         if {[lsearch $sigs $nsig] == -1} {
  993.             lappend ${var}s $nsig
  994.             lappend modifiedVars ${var}s
  995.         }
  996.         }
  997.     } else {
  998.         set nsig [lindex $sigs $p]
  999.     }
  1000.     return $nsig
  1001.     } else {
  1002.     return [dialog::_findApp $var $sig]
  1003.     }
  1004. }
  1005.  
  1006. proc dialog::findAnyApp {{prompt "Locate application:"}} {
  1007.     if {[catch {getfile $prompt} path]} {return ""}
  1008.     return $path
  1009. }
  1010.  
  1011. proc dialog::_findApp {var {sig ""}} {
  1012.     global alpha::platform
  1013.     if {${alpha::platform} == "alpha"} {
  1014.     set dir ""
  1015.     } else {
  1016.     set dir [file dirname $sig]
  1017.     }
  1018.     if {[catch {getfile "Locate new helper for '$var':" $sig} path]} { return "" }
  1019.     set nsig [getFileSig $path]
  1020.     set app [nameFromAppl $nsig]
  1021.     if {$app != $path} {
  1022.     alertnote "Appl sig '$nsig' is mapped to '$app', not '$path'. Remove the former, or rebuild your desktop."
  1023.     return ""
  1024.     }
  1025.     return $nsig
  1026. }
  1027.  
  1028. # ◊◊◊◊ Global/mode menus ◊◊◊◊ #
  1029.  
  1030. ## 
  1031.  # -------------------------------------------------------------------------
  1032.  # 
  1033.  # "dialog::pickMenusAndFeatures" --
  1034.  # 
  1035.  #  Prompt the user to select menus and features either globally or
  1036.  #  for a given mode.  We need to make sure that those items in
  1037.  #  the mode-list which are also in the global list aren't forgotten
  1038.  #  (since they are removed from the dialog).
  1039.  #  
  1040.  #  'mfb' is 0 for both menus and features
  1041.  #           1 for just menus
  1042.  #           2 for just features
  1043.  #           
  1044.  #  This procedure should be pretty clear now, having been rewritten.
  1045.  #  However, here are a few tips:
  1046.  #  
  1047.  #  Each page of the dialog may contain 2 or 3 sections.  The items
  1048.  #  to use in these sections are taken from the variables:
  1049.  #  
  1050.  #  menus1, menus2, menus3
  1051.  #  features1, features2, features3
  1052.  #  off1, off2
  1053.  #  
  1054.  #  Where if the variable is empty, the entire section is omitted.
  1055.  #  Furthermore, all 'always on' items are ignored, and for mode
  1056.  #  dialogs, anything which is globally on is moved from the menus
  1057.  #  or features pages to the 'off' pages.
  1058.  # -------------------------------------------------------------------------
  1059.  ##
  1060. proc dialog::pickMenusAndFeatures {formode {mfb 0}} {
  1061.     global mode::features global::features alpha::packagesAlwaysOn \
  1062.       index::flags index::feature
  1063.     set all [package::partition $formode]
  1064.     set menus1 [lindex $all 0]
  1065.     set menus2 [lindex $all 1]
  1066.     set menus3 [lindex $all 2]
  1067.     set features1 [lindex $all 3]
  1068.     set features2 [lindex $all 4]
  1069.     set features3 [lindex $all 5]
  1070.     unset all
  1071.     
  1072.     if {[info tclversion] >= 8.0} {
  1073.     set help {}
  1074.     }
  1075.     # decide on two or three column
  1076.     #set endw [expr [llength $all] > 50 ? 560 : 380]
  1077.     set endw 560
  1078.  
  1079.     if {$formode == "global"} {
  1080.     set chosen ${global::features}
  1081.     set prefix "Select global #"
  1082.     set maintypes [list Usual "" "Other possible"]
  1083.     } else {
  1084.     set chosen {}
  1085.     set extras_off {}
  1086.     set off1 {}
  1087.     set off2 {}
  1088.     foreach pkg [mode::getFeatures $formode] {
  1089.         if {[string index $pkg 0] == "-"} {
  1090.         set pkg [string range $pkg 1 end]
  1091.         if {[lsearch -exact ${global::features} $pkg] != -1} {
  1092.             # these are the ones which are disabled
  1093.             lappend extras_off $pkg
  1094.         }
  1095.         } else {
  1096.         # These are items which are on for this mode.  Any of these
  1097.         # which are also on globally go in the first group of 'off' 
  1098.         # items.  The rest in the first pages.
  1099.         lappend chosen $pkg
  1100.         }
  1101.     }
  1102.     foreach pkg [set global::features] {
  1103.         if {[lsearch -exact $chosen $pkg] != -1} {
  1104.         # The top group of items
  1105.         if {[lindex [set index::feature($pkg)] 2] == 1} {
  1106.             # it's a menu
  1107.             if {$mfb != 2} {lappend off1 $pkg}
  1108.         } else {
  1109.             # it's not a menu
  1110.             if {$mfb != 1} {lappend off1 $pkg}
  1111.         }
  1112.         } else {
  1113.         # The second group of items
  1114.         if {[lindex [set index::feature($pkg)] 2] == 1} {
  1115.             # it's a menu
  1116.             if {$mfb != 2} {lappend off2 $pkg}
  1117.         } else {
  1118.             # it's not a menu
  1119.             if {$mfb != 1} {lappend off2 $pkg}
  1120.         }
  1121.         }
  1122.     }
  1123.     
  1124.     set prefix "Select # for mode '$formode'"
  1125.     set maintypes [list Usual General "Other possible"]
  1126.     set multipage 1
  1127.     }
  1128.     while 1 {
  1129.     set maxh 0
  1130.     set box ""
  1131.     #set names {}
  1132.     foreach type {menus features off} {
  1133.         if {$formode == "global" && $type == "off"} {continue}
  1134.         if {$mfb > 0} {
  1135.         if {$mfb == 1 && $type == "features"} {continue}
  1136.         if {$mfb == 2 && $type == "menus"} {continue}
  1137.         }
  1138.         set w 20
  1139.         set h 45
  1140.         set i 0
  1141.         if {$type == "off"} {
  1142.         set subm "Turn items off"
  1143.         set types [list "Usually on for this mode" "Uncheck to disable"]
  1144.         } else {
  1145.         regsub "\#" $prefix $type subm
  1146.         set types $maintypes
  1147.         }
  1148.         set page 1
  1149.         if {![info exists names0]} {
  1150.         lappend names0 $subm
  1151.         lappend names $subm
  1152.         }
  1153.         lappend names $subm
  1154.         lappend box "-n" $subm
  1155.         if {$type == "off"} {
  1156.         lappend box -t "These items are currently globally on. You can turn them off just for this mode here."  10 $h [expr {$endw -20}] [expr {$h +15}]
  1157.         incr h 20
  1158.         }
  1159.         foreach block $types {
  1160.         incr i
  1161.         if {[llength [set ${type}$i]] == 0} {
  1162.             continue
  1163.         }
  1164.         if {($type == "off")} {
  1165.             lappend box -t "$block:"
  1166.         } else {
  1167.             lappend box -t "$block $type:" 
  1168.         }
  1169.         lappend box 10 $h [expr {$w +160}] [expr {$h +15}]
  1170.         incr h 20
  1171.         foreach m [set ${type}$i] {
  1172.             if {[lsearch -exact [set alpha::packagesAlwaysOn] $m] != -1} {
  1173.             continue
  1174.             }
  1175.             if {$h > 360} {
  1176.             if {$h > $maxh} {set maxh $h}
  1177.             incr page
  1178.             lappend names "$subm page $page"
  1179.             lappend box "-n" "$subm page $page"
  1180.             set h 45
  1181.             lappend box -t "$block $type continued..." 10 $h \
  1182.               [expr {$w +260}] [expr {$h +15}]
  1183.             incr h 20
  1184.             }
  1185.             set name [quote::Prettify $m]
  1186.             if {[info exists tmpcurrent]} {
  1187.             # Second or more times through we just recreate what we
  1188.             # have so far
  1189.             set tick [lindex $tmpcurrent $ii]
  1190.             incr ii
  1191.             } else {
  1192.             # First time through, we need to work out whether each item
  1193.             # is on or off, and rememeber all the items.
  1194.             if {$type == "off"} {
  1195.                 set tick [expr {([lsearch -exact $extras_off $m] < 0)}]
  1196.                 lappend orig [list "off" $m $tick]
  1197.             } else {
  1198.                 set tick [expr {([lsearch -exact $chosen $m] >= 0)}]
  1199.                 lappend orig [list "on" $m $tick]
  1200.             }
  1201.             }
  1202.             lappend box -c $name $tick $w $h  [expr {$w + 160}] [expr {$h + 15}]
  1203.             if {[info tclversion] >= 8.0} {
  1204.             lappend help [dialog::packagehelp $m 1]
  1205.             }
  1206.             incr w 180
  1207.             if {$w == $endw} {set w 20; incr h 20}
  1208.         }
  1209.         if {$w != 20} {
  1210.             incr h 30 ; set w 20
  1211.         }
  1212.         }
  1213.         if {$h > $maxh} {set maxh $h}
  1214.         
  1215.     }
  1216.     set h $maxh
  1217.     incr h 20
  1218.     
  1219.     if {[llength $names] == 2} {
  1220.         set offset 4
  1221.         set name_piece [list -t [lindex $names 0]]
  1222.         if {[set nindex [lsearch -exact $box -n]] != -1} {
  1223.         set box [lreplace $box $nindex [incr nindex]]
  1224.         }
  1225.         set singlepage 1
  1226.     } else {
  1227.         set offset 5
  1228.         set name_piece [list -m $names]
  1229.         set singlepage 0
  1230.     }
  1231.     
  1232.     if {[info tclversion] >= 8.0} {
  1233.         if {$formode == "global"} {
  1234.         set title "Global"
  1235.         } else {
  1236.         set title "$formode"
  1237.         }
  1238.         switch -- $mfb {
  1239.         0 { append title " menus and features" }
  1240.         1 { append title " menus" }
  1241.         2 { append title " features" }
  1242.         }
  1243.         lappend box -T $title
  1244.         set values [eval [concat dialog -w $endw -h [expr {$h + 30}] \
  1245.           -b OK 20 $h 85 [expr {$h + 20}] \
  1246.           -b Cancel 105 $h 170 [expr {$h + 20}]  \
  1247.           -b Help [expr {$endw -200}] $h [expr {$endw - 140}] [expr {$h + 20}] \
  1248.           -b Descriptions [expr {$endw -120}] $h [expr {$endw -20}] [expr {$h + 20}] \
  1249.           $name_piece [expr {($endw - 220)/2}] 10 $endw 30 $box\
  1250.           -help] [list [concat [list \
  1251.           "Click here to save the current settings." \
  1252.           "Click here to discard any changes you've made to the settings." \
  1253.           "Click here to access help on each item in this dialog." \
  1254.           "Click here to access descriptions of each item in this dialog."] \
  1255.           [expr {$singlepage ? "" : {"Use this popup menu, or the cursor keys to select a \
  1256.           different page of preferences."}}] \
  1257.           $help]]]
  1258.     } else {
  1259.         set values [eval [concat dialog -w $endw -h [expr {$h + 30}] \
  1260.           -b OK 20 $h 85 [expr {$h + 20}] \
  1261.           -b Cancel 105 $h 170 [expr {$h + 20}]  \
  1262.           -b Help [expr {$endw -200}] $h [expr {$endw - 140}] [expr {$h + 20}] \
  1263.           -b Descriptions [expr {$endw -120}] $h [expr {$endw -20}] [expr {$h + 20}] \
  1264.           $name_piece [expr {($endw - 220)/2}] 10 $endw 30 $box]]
  1265.     }
  1266.     
  1267.     if {[llength $names] > 2} {
  1268.         set names0 [list [lindex $values 4]]
  1269.     }
  1270.     set names $names0
  1271.     if {[lindex $values 0]} {
  1272.         set tmpcurrent [lrange $values $offset end]
  1273.         # Ok
  1274.         break
  1275.     }
  1276.     if {[lindex $values 1]} {
  1277.         # Cancel
  1278.         return
  1279.     }
  1280.     if {[lindex $values 2]} {
  1281.         dialog::describeMenusAndFeatures Help
  1282.     }
  1283.     if {[lindex $values 3]} {
  1284.         dialog::describeMenusAndFeatures Describe
  1285.     }    
  1286.     set tmpcurrent [lrange $values $offset end]
  1287.     set ii 0
  1288.     #unset names0
  1289.     }
  1290.     set res_on {}
  1291.     set res_off {}
  1292.     
  1293.     global mode
  1294.     
  1295.     for {set i 0} {$i < [llength $tmpcurrent]} {incr i} {
  1296.     set choice [lindex $tmpcurrent $i]
  1297.     set original [lindex $orig $i]
  1298.     set onoff [lindex $original 0]
  1299.     set m [lindex $original 1]
  1300.     set tick [lindex $original 2]
  1301.     if {$onoff == "on"} {
  1302.         # From the 'on' section of the dialog
  1303.         if {$choice && !$tick} {
  1304.         lappend res_on $m
  1305.         if {$formode == "global"} {
  1306.             lappend global::features $m
  1307.         } else {
  1308.             lappend mode::features($formode) $m
  1309.             prefs::modified mode::features($formode)
  1310.         }
  1311.         } elseif {!$choice && $tick} {
  1312.         lappend res_off $m
  1313.         if {$formode == "global"} {
  1314.             set global::features [lremove [set global::features] $m]
  1315.         } else {
  1316.             set mode::features($formode) [lremove [set mode::features($formode)] $m]
  1317.             prefs::modified mode::features($formode)
  1318.         }
  1319.         }
  1320.     } else {
  1321.         # From the 'off' section of the dialog
  1322.         if {$formode == "global"} {error "Shouldn't be here"}
  1323.         if {$choice && !$tick} {
  1324.         lappend res_on $m
  1325.         # It is on globally, and we previously turned it off for this mode
  1326.         set mode::features($formode) [lremove [set mode::features($formode)] "-$m"]
  1327.         } elseif {!$choice && $tick} {
  1328.         lappend res_off $m
  1329.         # It is on globally, and we now turn it off for this mode
  1330.         lappend mode::features($formode) "-$m"
  1331.         prefs::modified mode::features($formode)
  1332.         }
  1333.     }
  1334.     }
  1335.     # Finally carry out the (de)activation
  1336.     foreach m $res_off {
  1337.     package::deactivate $m
  1338.     }
  1339.     foreach m $res_on {
  1340.     package::activate $m
  1341.     }
  1342. }
  1343.  
  1344. proc dialog::describeMenusAndFeatures {{what "Help"}} {
  1345.     set all [package::partition]
  1346.     set okmenu [lindex $all 0]
  1347.     set okfeature [lindex $all 1]
  1348.     set okmode [lindex $all 2]
  1349.     set all [eval concat $all]
  1350.     # decide on two or three column
  1351.     set endw [expr {[llength $all] > 50 ? 560 : 380}]
  1352.     if {$what == "Help"} {
  1353.     set prefix "Read help for a #"
  1354.     } else {
  1355.     set prefix "Describe a #"
  1356.     }
  1357.     foreach m {menu feature mode} {
  1358.     regsub "\#" $prefix $m subm
  1359.     lappend names $subm
  1360.     }
  1361.     lappend box -m [concat [list [lindex $names 0]] $names] \
  1362.       [expr {($endw - 150)/2}] 10 $endw 30
  1363.     set maxh 0
  1364.     set wincr 160
  1365.     foreach type {menu feature mode} {
  1366.     set w 20
  1367.     set h 45
  1368.     regsub "\#" $prefix $type subm
  1369.     lappend box "-n" $subm
  1370.     if {$type == "mode"} {set wincr 70}
  1371.     foreach m [set ok$type] {
  1372.         set name [quote::Prettify $m]
  1373.         lappend box -b $name $w $h [expr {$w + $wincr}] [expr {$h + 15}]
  1374.         incr w [expr {$wincr +20}]
  1375.         if {$w == $endw} {set w 20; incr h 20}
  1376.     }
  1377.     if {$w > 20} {set w 20; incr h 20}
  1378.     if {$h > $maxh} {set maxh $h}
  1379.     }
  1380.     set h $maxh
  1381.     incr h 20
  1382.     while 1 {
  1383.     set values [eval [concat [list dialog -w $endw -h [expr {$h + 30}] \
  1384.       -b OK 20 $h 85 [expr {$h + 20}]] $box]]
  1385.     if {[lindex $values 0]} {return}
  1386.     # we hit a button
  1387.     for {set i 0} {$i < [llength $all]} {incr i} {
  1388.         if {[lindex $values [expr {$i + 2}]]} {
  1389.         if {$what == "Help"} {
  1390.             package::helpFile [lindex $all $i]
  1391.         } else {
  1392.             package::describe [lindex $all $i]
  1393.         }
  1394.         break
  1395.         }
  1396.     }
  1397.     }
  1398. }
  1399.  
  1400.  
  1401. # ◊◊◊◊ Multiple bindings dialogs ◊◊◊◊ #
  1402.  
  1403. proc dialog::arrayBindings {name array {for_menu 0}} {
  1404.     upvar $array a
  1405.     foreach n [array names a] {
  1406.     lappend l [list $a($n) $n]
  1407.     }
  1408.     if {[info exists l]} {
  1409.     eval dialog::adjustBindings [list $name modified "" $for_menu] $l
  1410.     }
  1411.     array set a [array get modified]
  1412. }
  1413.  
  1414. ## 
  1415.  # -------------------------------------------------------------------------
  1416.  # 
  1417.  # "dialog::adjustBindings" --
  1418.  # 
  1419.  #  'args' is a list of pairs.  The first element of each pair is the 
  1420.  #  menu binding, and the second element is a descriptive name for the
  1421.  #  element. 'array' is the name of an array in the calling proc's
  1422.  #  scope which is used to return modified bindings.
  1423.  # 
  1424.  # Results:
  1425.  #  
  1426.  # --Version--Author------------------Changes-------------------------------
  1427.  #    1.0     Johan Linde               original for html mode
  1428.  #    1.1     <vince@santafe.edu> general purpose version
  1429.  #    1.2     Johan Linde              split into two pages when many items
  1430.  # -------------------------------------------------------------------------
  1431.  ##
  1432. proc dialog::adjustBindings {name array {mod {}} {for_menu 1} args} {
  1433.     global screenHeight
  1434.     regsub -all {\"\(-\"} $args "" items
  1435.     upvar $array key_changes
  1436.     
  1437.     foreach it $items {
  1438.     if {[info exists key_changes([lindex $it 1])]} {
  1439.         set tmpKeys([lindex $it 1]) $key_changes([lindex $it 1])
  1440.     } else {
  1441.         set tmpKeys([lindex $it 1]) [lindex $it 0]
  1442.     }
  1443.     }
  1444.     # do we return modified stuff?
  1445.     if {$mod != ""} { upvar $mod modified }
  1446.     set modified ""
  1447.     set page "Page 1 of $name"
  1448.     while {1} {
  1449.     # Build dialog.
  1450.     set twoWindows 0
  1451.     set box ""
  1452.     set h 30
  1453.     foreach it $items {
  1454.         if {$it == "(-"} {continue}
  1455.         set w 210
  1456.         set w2 370
  1457.         set key $tmpKeys([lindex $it 1])
  1458.         set key1 [dialog::specialView::binding $key]
  1459.         set it2 [split [lindex $it 1] /]
  1460.         if {[llength $it2] == 1} {
  1461.         lappend box -t [lindex $it2 0] 65 $h 205 [expr {$h + 15}] -t $key1 $w $h $w2 [expr {$h + 15}]
  1462.         eval lappend box [dialog::buttonSet 10 $h]
  1463.         incr h 17
  1464.         } else {
  1465.         lappend box -t [lindex $it2 0] 65 $h 205 [expr {$h + 15}] -t $key1 $w $h $w2 [expr {$h + 15}]
  1466.         eval lappend box [dialog::buttonSet 10 [expr {$h +8}]]
  1467.         incr h 17
  1468.         if {$key1 != "<no binding>"} {regsub {((ctrl-)?(shift-)?)(.*)} $key1 {\1opt-\4} key1}
  1469.         lappend box -t [lindex $it2 1] 65 $h 205 [expr {$h + 15}] -t $key1 $w $h $w2 [expr {$h + 15}]
  1470.         incr h 17
  1471.         }
  1472.         if {$it != [lindex $items [expr {[llength $items] -1}]] && !$twoWindows && [set twoWindows [expr {$h + 100 > $screenHeight}]]} {
  1473.         set box " -n [list [concat Page 1 of $name]] $box -n [list [concat Page 2 of $name]] "
  1474.         set hmax $h; set h 30
  1475.         }
  1476.     }
  1477.     if {[info exists hmax]} {set h $hmax}
  1478.     if {$twoWindows} {
  1479.         set top "-m [list [list $page [concat Page 1 of $name] [concat Page 2 of $name]]] 10 10 370 25"
  1480.     } else {
  1481.         set top "-t [list $name] 50 10 250 25"
  1482.     }
  1483.     set buttons "-b OK 20 [expr {$h + 10}] 85 [expr {$h + 30}] -b Cancel 105 [expr {$h + 10}] 170 [expr {$h + 30}]"
  1484.     set values [eval [concat dialog -w 380 -h [expr {$h + 40}] $buttons $top $box]]
  1485.     if {$twoWindows} {set page [lindex $values 2]}
  1486.     if {[lindex $values 1]} {
  1487.         # Cancel
  1488.         return "Cancel"
  1489.     } elseif {[lindex $values 0]} {
  1490.         # Save new key bindings
  1491.         foreach it $modified {
  1492.         set key_changes($it) $tmpKeys($it)
  1493.         }
  1494.         return
  1495.     } else {
  1496.         # Get a new key.
  1497.         set it [lindex [lindex $items [expr {[lsearch $values 1] - 2 - $twoWindows}]] 1]
  1498.         if {![catch {dialog::getAKey $it $tmpKeys($it) $for_menu} newKey]  && $newKey != $tmpKeys($it)} {
  1499.         set tmpKeys($it) $newKey
  1500.         lappend modified $it
  1501.         }
  1502.     }
  1503.     }
  1504. }
  1505.  
  1506.  
  1507.